home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2009 February / PCWFEB09.iso / Software / Linux / Kubuntu 8.10 / kubuntu-8.10-desktop-i386.iso / casper / filesystem.squashfs / usr / share / perl5 / Pod / UsageTrans.pm
Encoding:
Perl POD Document  |  2008-01-17  |  9.7 KB  |  304 lines
  1. #############################################################################
  2. # Pod/UsageTrans.pm -- print translated usage messages for the running script.
  3. #
  4. # Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved.
  5. # Copyright (C) 2002 by SPI, inc.
  6. # Copyright (C) 2005 by Frank Lichtenheld.
  7. #
  8. #    This program is free software; you can redistribute it and/or modify
  9. #    it under the terms of the GNU General Public License as published by
  10. #    the Free Software Foundation; either version 2 of the License, or
  11. #    (at your option) any later version.
  12. #
  13. #    This program is distributed in the hope that it will be useful,
  14. #    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. #    GNU General Public License for more details.
  17. #
  18. #    You should have received a copy of the GNU General Public License
  19. #    along with this program; if not, write to the Free Software
  20. #    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  21. #
  22. #############################################################################
  23.  
  24. package Pod::UsageTrans;
  25.  
  26. use vars qw($VERSION);
  27. $VERSION = 0.1;  ## Current version of this package
  28. require  5.006;    ## requires this Perl version or later
  29.  
  30. =head1 NAME
  31.  
  32. Pod::UsageTrans, pod2usage() - print a usage message from embedded pod documentation
  33.  
  34. =head1 SYNOPSIS
  35.  
  36.   use Pod::UsageTrans
  37.   use Locale::gettext;
  38.  
  39.   setlocale(LC_MESSAGES,'');
  40.   textdomain('prog');
  41.  
  42.   my $message_text  = "This text precedes the usage message.";
  43.   my $exit_status   = 2;          ## The exit status to use
  44.   my $verbose_level = 0;          ## The verbose level to use
  45.   my $filehandle    = \*STDERR;   ## The filehandle to write to
  46.   my $textdomain    = 'prog-pod'; ## The gettext domain for the Pod documentation
  47.  
  48.   pod2usage($message_text);
  49.  
  50.   pod2usage($exit_status);
  51.  
  52.   pod2usage( { -message => gettext( $message_text ) ,
  53.                -exitval => $exit_status  ,
  54.                -verbose => $verbose_level,
  55.                -output  => $filehandle,
  56.                -textdomain => $textdomain } );
  57.  
  58.   pod2usage(   -msg     => $message_text ,
  59.                -exitval => $exit_status  ,
  60.                -verbose => $verbose_level,
  61.                -output  => $filehandle,
  62.                -textdomain => $textdomain );
  63.  
  64. =head1 DESCRIPTION
  65.  
  66. Pod::UsageTrans works exactly like Pod::Usage but allows you
  67. to easily translate your messages. It was specifically written to
  68. be compatible with the F<.po> files produced by po4a(7). If you
  69. want to use any other method to produce your F<.po> files you
  70. should probably take a look at the source of code of this module
  71. to see which msgids you will need to use.
  72.  
  73. For documentation on calling pod2usage from your program see
  74. Pod::Usage. Pod::UsageTrans additionally supports a C<-textdomain>
  75. option where you can specify the gettext domain to use. If
  76. C<-textdomain> isn't set, Pod::UsageTrans will behave exactly
  77. like Pod::Usage.
  78.  
  79. =head1 BUGS
  80.  
  81. Pod::UsageTrans is currently in the state of a quickly hacked together
  82. solution that was tested with exactly one use case. Expect bugs in
  83. corner cases.
  84.  
  85. It specifically doesn't support many of the po4a options like charset
  86. conversion between the POD input and the msgstr in the F<.pot> file.
  87.  
  88. =head1 SEE ALSO
  89.  
  90. po4a(7), Pod::Usage, gettext info documentation
  91.  
  92. =head1 AUTHOR
  93.  
  94. Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt>
  95.  
  96. Based on Pod::Usage by Brad Appleton E<lt>bradapp@enteract.comE<gt>
  97. which is based on code for B<Pod::Text::pod2text()> written by
  98. Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
  99.  
  100. Also based on Locale::Po4a::Pod, Locale::Po4a::Po and
  101. Locale::Po4a::TransTractor by Martin Quinson and Denis Barbier.
  102.  
  103. =cut
  104.  
  105. #############################################################################
  106.  
  107. use strict;
  108. #use diagnostics;
  109. use Carp;
  110. use Config;
  111. use Exporter;
  112. use File::Spec;
  113. use Pod::Usage ();
  114. use Locale::gettext;
  115.  
  116. use vars qw(@ISA @EXPORT);
  117. @EXPORT = qw(&pod2usage);
  118. @ISA = qw( Pod::Usage );
  119.  
  120. ##---------------------------------------------------------------------------
  121.  
  122. ##---------------------------------
  123. ## Function definitions begin here
  124. ##---------------------------------
  125.  
  126. # I had to copy the ENTIRE pod2usage just to make a one-line change
  127. # s/Pod::Usage/Pod::UsageTrans/. Maybe I can convince upstream to allow
  128. # more easy overriding?
  129. sub pod2usage {
  130.     local($_) = shift || "";
  131.     my %opts;
  132.     ## Collect arguments
  133.     if (@_ > 0) {
  134.         ## Too many arguments - assume that this is a hash and
  135.         ## the user forgot to pass a reference to it.
  136.         %opts = ($_, @_);
  137.     }
  138.     elsif (ref $_) {
  139.         ## User passed a ref to a hash
  140.         %opts = %{$_}  if (ref($_) eq 'HASH');
  141.     }
  142.     elsif (/^[-+]?\d+$/) {
  143.         ## User passed in the exit value to use
  144.         $opts{"-exitval"} =  $_;
  145.     }
  146.     else {
  147.         ## User passed in a message to print before issuing usage.
  148.         $_  and  $opts{"-message"} = $_;
  149.     }
  150.  
  151.     ## Need this for backward compatibility since we formerly used
  152.     ## options that were all uppercase words rather than ones that
  153.     ## looked like Unix command-line options.
  154.     ## to be uppercase keywords)
  155.     %opts = map {
  156.         my $val = $opts{$_};
  157.         s/^(?=\w)/-/;
  158.         /^-msg/i   and  $_ = '-message';
  159.         /^-exit/i  and  $_ = '-exitval';
  160.         lc($_) => $val;
  161.     } (keys %opts);
  162.  
  163.     ## Now determine default -exitval and -verbose values to use
  164.     if ((! defined $opts{"-exitval"}) && (! defined $opts{"-verbose"})) {
  165.         $opts{"-exitval"} = 2;
  166.         $opts{"-verbose"} = 0;
  167.     }
  168.     elsif (! defined $opts{"-exitval"}) {
  169.         $opts{"-exitval"} = ($opts{"-verbose"} > 0) ? 1 : 2;
  170.     }
  171.     elsif (! defined $opts{"-verbose"}) {
  172.         $opts{"-verbose"} = (lc($opts{"-exitval"}) eq "noexit" ||
  173.                              $opts{"-exitval"} < 2);
  174.     }
  175.  
  176.     ## Default the output file
  177.     $opts{"-output"} = (lc($opts{"-exitval"}) eq "noexit" ||
  178.                         $opts{"-exitval"} < 2) ? \*STDOUT : \*STDERR
  179.             unless (defined $opts{"-output"});
  180.     ## Default the input file
  181.     $opts{"-input"} = $0  unless (defined $opts{"-input"});
  182.  
  183.     ## Look up input file in path if it doesnt exist.
  184.     unless ((ref $opts{"-input"}) || (-e $opts{"-input"})) {
  185.         my ($dirname, $basename) = ('', $opts{"-input"});
  186.         my $pathsep = ($^O =~ /^(?:dos|os2|MSWin32)$/) ? ";"
  187.                             : (($^O eq 'MacOS' || $^O eq 'VMS') ? ',' :  ":");
  188.         my $pathspec = $opts{"-pathlist"} || $ENV{PATH} || $ENV{PERL5LIB};
  189.  
  190.         my @paths = (ref $pathspec) ? @$pathspec : split($pathsep, $pathspec);
  191.         for $dirname (@paths) {
  192.             $_ = File::Spec->catfile($dirname, $basename)  if length;
  193.             last if (-e $_) && ($opts{"-input"} = $_);
  194.         }
  195.     }
  196.  
  197.     ## Now create a pod reader and constrain it to the desired sections.
  198.     my $parser = new Pod::UsageTrans(USAGE_OPTIONS => \%opts);
  199.     if ($opts{"-verbose"} == 0) {
  200.         $parser->select("SYNOPSIS");
  201.     }
  202.     elsif ($opts{"-verbose"} == 1) {
  203.         my $opt_re = '(?i)' .
  204.                      '(?:OPTIONS|ARGUMENTS)' .
  205.                      '(?:\s*(?:AND|\/)\s*(?:OPTIONS|ARGUMENTS))?';
  206.         $parser->select( 'SYNOPSIS', $opt_re, "DESCRIPTION/$opt_re" );
  207.     }
  208.     elsif ($opts{"-verbose"} == 99) {
  209.         $parser->select( $opts{"-sections"} );
  210.         $opts{"-verbose"} = 1;
  211.     }
  212.  
  213.     ## Now translate the pod document and then exit with the desired status
  214.     if ( $opts{"-verbose"} >= 2 
  215.              and  !ref($opts{"-input"})
  216.              and  $opts{"-output"} == \*STDOUT )
  217.     {
  218.        ## spit out the entire PODs. Might as well invoke perldoc
  219.        my $progpath = File::Spec->catfile($Config{scriptdir}, "perldoc");
  220.        system($progpath, $opts{"-input"});
  221.     }
  222.     else {
  223.        $parser->parse_from_file($opts{"-input"}, $opts{"-output"});
  224.     }
  225.  
  226.     exit($opts{"-exitval"})  unless (lc($opts{"-exitval"}) eq 'noexit');
  227. }
  228.  
  229. sub canonize {
  230.     my $text=shift;
  231. #    print STDERR "\ncanonize [$text]====" if $debug{'canonize'};
  232.     $text =~ s/^ *//s;
  233.     $text =~ s/^[ \t]+/  /gm;
  234.     # if ($text eq "\n"), it messed up the first string (header)
  235.     $text =~ s/\n/  /gm if ($text ne "\n");
  236.     $text =~ s/([.)])  +/$1  /gm;
  237.     $text =~ s/([^.)])  */$1 /gm;
  238.     $text =~ s/ *$//s;
  239. #    print STDERR ">$text<\n" if $debug{'canonize'};
  240.     return $text;
  241. }
  242.  
  243. ##---------------------------------------------------------------------------
  244.  
  245. ##-------------------------------
  246. ## Method definitions begin here
  247. ##-------------------------------
  248.  
  249. sub translate {
  250.     my ($self, $string, %options) = @_;
  251.  
  252.     $string = canonize($string) if $options{wrap};
  253.  
  254. #    print "domain: $self->{USAGE_OPTIONS}->{-textdomain}, string:\"$string\"\n";
  255.     return dgettext( $self->{USAGE_OPTIONS}->{"-textdomain"},
  256.              $string ) if $self->{USAGE_OPTIONS}->{"-textdomain"};
  257.     return $string;
  258. }
  259.  
  260. sub command {
  261.     my ($self, $command, $paragraph, $line_num) = @_;
  262. #    print STDOUT "cmd: '$command' '$paragraph' at $line_num\n";
  263.     if ($command eq 'back'
  264.     || $command eq 'cut'
  265.     || $command eq 'pod'
  266.     || $command eq 'over') {
  267.     } else {
  268.     $paragraph=$self->translate($paragraph,
  269.                     "wrap"=>1);
  270.     }
  271.     return $self->SUPER::command( $command, $paragraph, $line_num );
  272. }
  273.  
  274. sub verbatim {
  275.     my ($self, $paragraph, $line_num) = @_;
  276. #    print "verb: '$paragraph' at $line_num\n";
  277.  
  278.     if ($paragraph eq "\n") {
  279.     return;
  280.     }
  281.     $paragraph=$self->translate($paragraph);
  282.     return $self->SUPER::verbatim( $paragraph, $line_num );
  283. }
  284.  
  285. sub textblock {
  286.     my ($self, $paragraph, $line_num) = @_;
  287. #    print "text: '$paragraph' at $line_num\n";
  288.  
  289.     if ($paragraph eq "\n") {
  290.     return;
  291.     }
  292.     if ($paragraph =~ m/^[ \t]/m) {
  293.     $self->verbatim($paragraph, $line_num) ;
  294.     return;
  295.     }
  296.  
  297.     $paragraph=$self->translate($paragraph,
  298.                 "wrap"=>1);
  299.     return $self->SUPER::textblock( $paragraph, $line_num );
  300. }
  301.  
  302.  
  303. 1; # keep require happy
  304.